home *** CD-ROM | disk | FTP | other *** search
/ MacTech 1 to 12 / MacTech-vol-1-12.toast / Source / MacTech® Magazine / Volume 07 - 1991 / 07.03 Mar 91 / sndMgr.Lisp
Encoding:
Text File  |  1990-09-27  |  7.6 KB  |  226 lines  |  [TEXT/CCL ]
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;; sndMgr.Lisp
  3. ;;
  4. ;; Copyright © 1990 Michael S. Engber
  5. ;; All Rights Reserved
  6. ;;
  7. ;; Sound Manager access from LISP
  8. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  9.  
  10. (require 'traps)
  11.  
  12. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13. ;;; Sound Manager definitions (missing from Records.Lisp)
  14. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  15.  
  16. (eval-when (compile load eval)
  17.   
  18.   (defrecord (SndCommand :pointer)
  19.     (cmd :integer)
  20.     (param1 :integer)
  21.     (param2 :longint)
  22.     )
  23.   
  24.   (defrecord (SndChannel :pointer)
  25.     (nextChan :pointer)
  26.     (firstMode :pointer)
  27.     (callBack :pointer)
  28.     (userInfo :longint)
  29.     (wait :longint) ;Time
  30.     (cmdInProgress SndCommand)
  31.     (flags :integer)
  32.     (qLength :integer)
  33.     (qHead :integer)
  34.     (qTail :integer)
  35.     (queue :longint) ;array [0..stdQLength-1] of SndCommand
  36.     )
  37.   
  38.   ;;; sound commands
  39.   (defconstant $nullCmd 0)
  40.   (defconstant $initCmd 1)
  41.   (defconstant $freeCmd 2)
  42.   (defconstant $quietCmd 3)
  43.   (defconstant $flushCmd 4)
  44.   (defconstant $waitCmd 10)
  45.   (defconstant $pauseCmd 11)
  46.   (defconstant $resumeCmd 12)
  47.   (defconstant $callBackCmd 13)
  48.   (defconstant $syncCmd 14)
  49.   (defconstant $emptyCmd 15)
  50.   (defconstant $tickleCmd 20)
  51.   (defconstant $requestNextCmd 21)
  52.   (defconstant $howOftenCmd 22)
  53.   (defconstant $wakeUpCmd 23)
  54.   (defconstant $availableCmd 24)
  55.   (defconstant $versionCmd 25)
  56.   (defconstant $scaleCmd 30)
  57.   (defconstant $tempoCmd 31)
  58.   (defconstant $noteCmd 40)
  59.   (defconstant $restCmd 41)
  60.   (defconstant $freqCmd 42)
  61.   (defconstant $ampCmd 43)
  62.   (defconstant $timbreCmd 44)
  63.   (defconstant $waveTableCmd 60)
  64.   (defconstant $phaseCmd 61)
  65.   (defconstant $soundCmd 80)
  66.   (defconstant $bufferCmd 81)
  67.   (defconstant $rateCmd 82)
  68.   (defconstant $continueCmd 83)
  69.   (defconstant $midiDataCmd 100)
  70.   
  71. )
  72.  
  73. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  74.  
  75. (defvar *snd-channel_p* nil "pointer to currently opened sound channel")
  76.  
  77. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  78.  
  79. (defmacro with-sound (sndSpec &rest forms)
  80.   "(sndSpec) -forms-
  81. Protective 'with' wrapper for using sounds."
  82.   (unless (listp sndSpec) (error "bad options"))
  83.   `(unwind-protect (progn (snd-open ,(first sndSpec)) ,@forms) (snd-close)))
  84.  
  85. (defun snd-halt ()
  86.   "void
  87. Halts any sound in progress & closes the channel."
  88.   (when *snd-channel_p*
  89.     (snd-command-immediate $quietCmd 0 0)
  90.     (snd-command-immediate $flushCmd 0 0)
  91.     (snd-close)))
  92.  
  93. (defun snd-p ()
  94.   "void
  95. Returns whether a sound (played with snd-open) is currently playing."
  96.   (when *snd-channel_p*
  97.     (null (zerop (rref *snd-channel_p* :SndChannel.userInfo)))))
  98.  
  99. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  100. ;; snd-open & snd-close open a sound channel, play a sound, and then close
  101. ;; the sound channel. Since only one sound channel can be active at any time,
  102. ;; it is important that every call to snd-open be followed by a call to
  103. ;; snd-close (or snd-halt) as soon as possible. While a sound channel is open,
  104. ;; no other sounds (like system beeps) can play.
  105. ;;
  106. ;; The with-sound macro safely takes care of all this for you. When control
  107. ;; leaves the body, either normally or abnormally, the sound channel is closed.
  108.  
  109. (defun snd-open (sndSpec &key (async t))
  110.   "sndSpec &key (async t)
  111. Plays the specified sound (asynchronously by default)
  112. sndSpec is either a resource number or name of a 'snd ' resource."
  113.   (let ((snd_h (get-snd sndSpec)))
  114.     (when snd_h
  115.       (cond
  116.        (async
  117.         (snd-open-channel)
  118.         (rset *snd-channel_p* :SndChannel.userInfo -1)
  119.         (_SndPlay :ptr *snd-channel_p* :ptr snd_h :word -1 :word)
  120.         (snd-command $callBackCmd 0 0))
  121.        (t
  122.         (snd-close)
  123.         (_SndPlay :ptr nil :ptr snd_h :word 0 :word))))))
  124.  
  125. (defun snd-close ()
  126.   "void
  127. Cleans up after sound finishes."
  128.   (snd-close-channel))
  129.  
  130. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  131.  
  132. ;; Determining whether a sound is still playing (snd-p) is done using a
  133. ;; Sound Manager call back routines. Before playing a sound, the userInfo
  134. ;; field of the sound channel is set to -1. When the sound completes, the
  135. ;; call back routine is called and it sets userInfo to zero. snd-p simply
  136. ;; checks the value of userInfo.
  137. ;;
  138. ;; Since the call back routine is called at interrupt time, there are several
  139. ;; restrictions on it (see Sound Manager chapter of IM) which MACL's defpascal
  140. ;; mechanism does not obey. So it was written in C. The compiled code is small
  141. ;; enough that we can just copy its machine code into memory when a sound channel
  142. ;; is created (avoiding loading CODE resources or external function calls)
  143. ;;
  144. ;;     #include <SoundMgr.h>
  145. ;;
  146. ;;     pascal void main (SndChannelPtr theChan, SndCommand* theCmd){
  147. ;;      theChan->userInfo = 0L;
  148. ;;     }
  149. ;;
  150. ;; 
  151.  
  152. (defvar *snd-call-back-mcode* "600E0000434F444501F400000000000041FAFFEE4E714E71600000024E560000206E000C42A8000C4E5E205F4FEF00084ED04D41494E20202020"
  153.   "machine code (hex) for call back routine")
  154.  
  155. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  156.  
  157. (defun get-snd (sndSpec)
  158.   "sndSpec
  159. Returns a handle to the specified 'snd ' resource.
  160. sndSpec is either a resource number or name of a 'snd ' resource."
  161.   (typecase sndSpec
  162.    (fixnum (_GetResource :ostype "snd " :word sndSpec :ptr))
  163.    (string (with-pstrs ((name sndSpec))
  164.              (_GetNamedResource :ostype "snd " :ptr name  :ptr)))
  165.    (otherwise (error "bad resource specification [~S]" sndSpec))))
  166.  
  167. (defun snd-open-channel ()
  168.   "void
  169. Opens a new channel for sound play."
  170.   (when *snd-channel_p* (snd-close-channel))
  171.   (%stack-block ((channel_p 4))
  172.     
  173.     ;; pass nil for the channel_p so the Sound Mangager will allocate space
  174.     (%put-ptr channel_p nil)
  175.     
  176.     ;; stuff machine code for call back routine into memory
  177.     (let ((call-back-ptr (_NewPtr  :d0 (/ (length *snd-call-back-mcode*) 2) :a0)))
  178.       (with-pstrs ((p *snd-call-back-mcode*))
  179.         (_StuffHex :ptr call-back-ptr :ptr p))
  180.     
  181.     (if (zerop (_SndNewChanne :ptr channel_p :word 0 :long 0 :ptr call-back-ptr :word))
  182.       (setf *snd-channel_p* (%get-ptr channel_p))
  183.       (error "unable to allocate new sound channel.")))))
  184.  
  185. (defun snd-close-channel ()
  186.   (when *snd-channel_p*
  187.     (_DisposPtr :a0 (rref *snd-channel_p* :SndChannel.callBack) :d0)
  188.     (_SndDisposeChannel :ptr *snd-channel_p* :word 0 :word)
  189.     (setf *snd-channel_p* nil)))
  190.  
  191. (defun snd-command (cmd param1 param2)
  192.   "cmd  param1 param2
  193. Adds the specified command to the sound channel's queue."
  194.   (when *snd-channel_p*
  195.     (rlet ((cmd_p :SndCommand :cmd cmd :param1 param1 :param2 param2))
  196.       (_SndDoCommand :ptr *snd-channel_p* :ptr cmd_p :word 0 :word))))
  197.  
  198. (defun snd-command-immediate (cmd param1 param2)
  199.   "cmd param1 param2
  200. Sends the sound channel the specified command to immediately execute."
  201.   (when *snd-channel_p*
  202.     (rlet ((cmd_p :SndCommand :cmd cmd :param1 param1 :param2 param2))
  203.       (_SndDoImmediat :ptr *snd-channel_p* :ptr cmd_p :word))))
  204.  
  205.  
  206. #|
  207.  
  208. test code
  209.  
  210. This plays a sound asychronously. During play it checks to see if
  211. the shift key is pressed - if so it halts the sound immediatlely.
  212. It uses the 'snd ' resource id = 1, the standard system beep.
  213.  
  214. (with-sound (1)
  215.     (loop (when (or (shift-key-p) (null (snd-p))) (snd-halt) (return))))
  216.  
  217. The standard system beep is so short that the above code isn't too
  218. exciting as is. You may want to try some of the longer system beeps
  219. like Clink-Klang (id = 2) if you have them installed. Or better yet,
  220. open a sound resource file of your own with this code.
  221.  
  222. (with-pstrs ((res_file "insert path to your sound file"))
  223.   (_openresfile :ptr res_file :word))
  224.  
  225. |#
  226.